home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacMETH 3.2.1 / Sources / MacC3.3 / CompileN.MOD < prev    next >
Encoding:
Text File  |  1994-11-11  |  41.8 KB  |  1,364 lines  |  [TEXT/MEDT]
  1. MODULE CompileN; (* NW 6.3.83; WH 30.9.87; HS 17.9.91 / 11.11.94 *)
  2.  
  3.   (* Implementation according to Programming in Modula-2, Fourth Edition. *)
  4.  
  5.   FROM Terminal IMPORT BusyRead, Read, Write, WriteLn, WriteString;
  6.   FROM FileSystem IMPORT File, Lookup, ReadChar, Response, Close, Delete;
  7.   FROM FileUtil IMPORT Path, termCh, ReadFileName, ExtLookup,
  8.        GetCurrentPath, AddPath;
  9.   IMPORT FPControl; (* must be first imported compiler module ! *)
  10.   FROM M2ClockA IMPORT Time, GetTime;
  11.   FROM M2DA IMPORT
  12.        WordSize, MaxInt, Standard, rngchk, ovflchk,
  13.        inttyp, cardtyp, realtyp, chartyp, bitstyp, dbltyp, notyp,
  14.        stringtyp, lrltyp, undftyp, mainmod, sysmod,
  15.        ObjPtr, StrPtr, ParPtr, ConstValue, StrForm, ObjClass;
  16.   FROM M2SA IMPORT
  17.        Symbol, sym, id, numtyp, intval, dblval, realval, lrlval, source, IdBuf,
  18.        scanerr, InitScanner, GetSym, Diff, KeepId, Mark, CloseScanner;
  19.   FROM M2TA IMPORT
  20.        topScope, Scope, NewObj, NewStr, NewPar, NewImp,
  21.        NewScope, CloseScope, Find, FindImport, FindInScope, CheckUDP,
  22.        MarkHeap, ReleaseHeap, InitTableHandler;
  23.   FROM M2RA IMPORT
  24.        ModNo, ModList, RefFile,
  25.        InitRef, InRef, OpenRef, RefPoint, OutUnit, CloseRef;
  26.   FROM M2EA IMPORT
  27.        GlbVarStartAdr, LocVarStartAdr, GlbParStartAdr, LocParStartAdr,
  28.        wlev, AllocVar, AllocPar, AllocFld,
  29.        GenItem, GenIndex, GenField, GenDeRef, GenNeg, GenNot, GenAnd,
  30.        GenOr, GenSingSet, GenSet, GenIn, GenOp, GenWith, GenWith2,
  31.        GenStParam, GenStFct, InitM2EM;
  32.   FROM M2CA IMPORT
  33.        LabelRange, ExitTable, curPrio, GenAssign, GenFJ, GenCFJ, GenBJ, GenCBJ,
  34.        PrepCall, GenParam, GenCall, GenEnter, GenResult, GenReturn,
  35.        GenCase1, GenCase2, GenCase3, GenFor1, GenFor2, GenFor3, GenFor4,
  36.        GenLoop1, GenLoop2, GenExit, GenEnterMod, GenExitMod;
  37.   FROM M2HA IMPORT
  38.        DynArrDesSize, ItemMode, Item, curLev,
  39.        LongVal, WordVal, CheckRegs, SetregMd, SetconMd, LoadD,
  40.        ConvertTyp, CopyDynArray, GenHalt, Processor, ProcessorID, InitM2HM;
  41.   FROM M2LA IMPORT
  42.        pc, AllocString, AllocBounds, fixup, FixLink,
  43.        FixupWith, OutCodeFile, InitM2LM;
  44.  
  45.  
  46.   CONST NL = 63;
  47.         NofCases     = 128;
  48.         NofExits      = 16;
  49.         LoopLevels     = 4;
  50.         EnumTypSize    = 1;
  51.         SetTypSize     = WordSize DIV 8;
  52.         PointerTypSize = 4;
  53.         ProcTypSize    = 4;
  54.         ESC = 3C;
  55.  
  56.  
  57.   VAR ch: CHAR;
  58.       pno: INTEGER;
  59.       mno: INTEGER;
  60.       isdef, isimp, ok: BOOLEAN;
  61.       FileName, TempName: ARRAY [0..NL] OF CHAR;
  62.       processor: Processor;
  63.       i: INTEGER;
  64.       TM: Time;
  65.       path: Path;
  66.  
  67.  
  68.   PROCEDURE Type(VAR typ: StrPtr); FORWARD;
  69.   PROCEDURE Expression(VAR x: Item); FORWARD;
  70.   PROCEDURE Block(ancestor: ObjPtr; qual: BOOLEAN;
  71.             VAR adr: INTEGER; VAR L0: INTEGER); FORWARD;
  72.  
  73.   PROCEDURE err(n: INTEGER);
  74.   BEGIN Mark(n)
  75.   END err;
  76.  
  77.   PROCEDURE CheckSym(s: Symbol; n: INTEGER);
  78.   BEGIN
  79.     IF sym = s THEN GetSym ELSE Mark(n) END
  80.   END CheckSym;
  81.  
  82.   PROCEDURE qualident(VAR obj: ObjPtr);
  83.   BEGIN
  84.     obj := Find(id); GetSym;
  85.     WHILE (sym = period) & (obj # NIL) & (obj^.class = Module) DO
  86.       GetSym;
  87.       IF sym = ident THEN
  88.         obj := FindInScope(id, obj^.root); GetSym;
  89.         IF (obj # NIL) & NOT obj^.exported THEN obj := NIL END
  90.       ELSE err(10)
  91.       END
  92.     END
  93.   END qualident;
  94.  
  95.   PROCEDURE GenVal(VAR x: Item);
  96.   BEGIN
  97.     IF x.mode = cocMd THEN LoadD(x) END;
  98.   END GenVal;
  99.  
  100.   PROCEDURE ConstExpression(VAR x: Item);
  101.   BEGIN Expression(x);
  102.     IF x.mode # conMd THEN
  103.       err(44);
  104.       SetconMd(x, 1D, undftyp);
  105.     END
  106.   END ConstExpression;
  107.  
  108.   PROCEDURE CheckComp(t0, t1: StrPtr);
  109.   BEGIN
  110.     IF t0^.form = Range THEN t0 := t0^.RBaseTyp END;
  111.     IF t1^.form = Range THEN t1 := t1^.RBaseTyp END;
  112.     IF t0 # t1 THEN
  113.       err(61); (* incompatible type of label or subrange bound *)
  114.     END;
  115.   END CheckComp;
  116.  
  117.   PROCEDURE CaseLabelList(Ltyp: StrPtr; VAR n: INTEGER; VAR tab: ARRAY OF LabelRange);
  118.   VAR x,y: Item; i,j: INTEGER; f: StrForm;
  119.   BEGIN f := Ltyp^.form;
  120.     IF f = Range THEN Ltyp := Ltyp^.RBaseTyp
  121.     ELSIF (f < Bool) OR ((f > Enum) & (f # Double)) THEN err(83)
  122.     END;
  123.     LOOP ConstExpression(x);
  124.       IF (Ltyp # dbltyp) OR (x.typ # inttyp) THEN CheckComp(Ltyp, x.typ) END;
  125.       IF sym = ellipsis THEN
  126.         GetSym; ConstExpression(y);
  127.         IF (Ltyp # dbltyp) OR (y.typ # inttyp) THEN CheckComp(Ltyp, y.typ) END;
  128.         IF LongVal(x) > LongVal(y) THEN err(63); y := x END;
  129.       ELSE y := x
  130.       END;
  131.       IF ABS(LongVal(y)) > 32767D THEN err(138) END;
  132.       (* enter label range into ordered table *) i := n;
  133.       IF i < NofCases THEN
  134.         LOOP
  135.           IF i = 0 THEN EXIT END;
  136.           IF tab[i-1].low <= WordVal(y) THEN
  137.             IF tab[i-1].high >= WordVal(x) THEN err(62) END;
  138.             EXIT
  139.           END;
  140.           tab[i] := tab[i-1]; DEC(i)
  141.         END;
  142.         WITH tab[i] DO
  143.           low := WordVal(x); high := WordVal(y); label := pc
  144.         END;
  145.         INC(n)
  146.       ELSE err(92)
  147.       END;
  148.       IF sym = comma THEN GetSym
  149.       ELSIF (sym = number) OR (sym = ident) THEN err(11)
  150.       ELSE EXIT
  151.       END
  152.     END
  153.   END CaseLabelList;
  154.  
  155.   PROCEDURE Subrange(VAR typ: StrPtr);
  156.   VAR x, y: Item; f, g: StrForm;
  157.   BEGIN typ := NewStr(Range); ConstExpression(x); f := x.typ^.form;
  158.     IF (f >= Bool) & (f <= Enum) THEN typ^.min := WordVal(x) ELSE err(82) END;
  159.     CheckSym(ellipsis, 21); ConstExpression(y); g := y.typ^.form;
  160.     CheckComp(x.typ, y.typ);
  161.     WITH typ^ DO max := WordVal(y);
  162.       IF min > max THEN
  163.         err(63); min := max
  164.       END;
  165.       RBaseTyp := x.typ; size := x.typ^.size;
  166.       IF rngchk THEN AllocBounds(min, max, size, BndAdr) END
  167.     END
  168.   END Subrange;
  169.  
  170.   PROCEDURE SimpleType(VAR typ: StrPtr);
  171.   VAR obj, last: ObjPtr; typ0: StrPtr; n: INTEGER;
  172.   BEGIN typ := undftyp;
  173.     IF sym = ident THEN
  174.       qualident(obj);
  175.       IF (obj # NIL) & (obj^.class = Typ) THEN typ := obj^.typ
  176.         ELSE err(52)
  177.       END;
  178.       IF sym = lbrak THEN
  179.         WHILE typ^.form = Range DO typ := typ^.RBaseTyp END;
  180.         GetSym; typ0 := typ; Subrange(typ);
  181.         IF typ^.RBaseTyp # typ0 THEN
  182.           IF (typ0 = inttyp) & (typ^.RBaseTyp = cardtyp) THEN
  183.             typ^.RBaseTyp := inttyp
  184.           ELSE err(61)
  185.           END
  186.         END;
  187.         IF sym = rbrak THEN GetSym ELSE err(16);
  188.           IF sym = rparen THEN GetSym END
  189.         END
  190.       END
  191.     ELSIF sym = lparen THEN
  192.       GetSym; typ := NewStr(Enum); last := NIL; n := 0;
  193.       LOOP
  194.         IF sym = ident THEN
  195.           obj := NewObj(id, Const); KeepId;
  196.           obj^.conval.Ch := CHR(n MOD 256);
  197.           IF n > 255 THEN err(300) END;
  198.           obj^.conval.prev := last; obj^.typ := typ;
  199.           last := obj; INC(n); GetSym
  200.         ELSE err(10)
  201.         END;
  202.         IF sym = comma THEN GetSym
  203.         ELSIF sym = ident THEN err(11)
  204.         ELSE EXIT
  205.         END
  206.       END;
  207.       WITH typ^ DO
  208.         ConstLink := last; NofConst := n; size := EnumTypSize
  209.       END;
  210.       CheckSym(rparen, 15)
  211.     ELSIF sym = lbrak THEN
  212.       GetSym; Subrange(typ);
  213.       IF sym = rbrak THEN GetSym ELSE err(16);
  214.         IF sym = rparen THEN GetSym END
  215.       END
  216.     ELSE err(32)
  217.     END
  218.   END SimpleType;
  219.  
  220.   PROCEDURE FieldListSequence(VAR maxadr: INTEGER; adr: INTEGER);
  221.   VAR fld1, last, tagfldtyp: ObjPtr; typ: StrPtr;
  222.  
  223.     PROCEDURE VariantPart;
  224.     VAR lastadr, N: INTEGER;
  225.         tab: ARRAY [0..NofCases-1] OF LabelRange;
  226.     BEGIN maxadr := adr; N := 0;
  227.       LOOP
  228.         IF sym < bar THEN CaseLabelList(typ, N, tab);
  229.           CheckSym(colon, 13); FieldListSequence(lastadr, adr);
  230.           IF lastadr > maxadr THEN maxadr := lastadr END
  231.         END;
  232.         IF sym = bar THEN GetSym ELSE EXIT END
  233.       END;
  234.       IF sym = else THEN
  235.         GetSym; FieldListSequence(lastadr, adr);
  236.         IF lastadr > maxadr THEN maxadr := lastadr END
  237.       END
  238.     END VariantPart;
  239.  
  240.   BEGIN typ := undftyp;
  241.     IF (sym = ident) OR (sym = case) THEN
  242.       LOOP
  243.         IF sym = ident THEN last := topScope^.last;
  244.           LOOP
  245.             IF sym = ident THEN
  246.               fld1 := NewObj(id, Field); KeepId; GetSym
  247.             ELSE err(10)
  248.             END;
  249.             IF sym = comma THEN GetSym
  250.             ELSIF sym = ident THEN err(11)
  251.             ELSE EXIT
  252.             END
  253.           END;
  254.           CheckSym(colon, 13); Type(typ);
  255.           fld1 := last^.next;
  256.           WHILE fld1 # NIL DO
  257.             fld1^.typ := typ; AllocFld(fld1, adr); fld1 := fld1^.next
  258.           END
  259.         ELSIF sym = case THEN
  260.           GetSym; fld1 := NIL; tagfldtyp := NIL;
  261.           IF sym = ident THEN
  262.             fld1 := NewObj(id, Field); KeepId; GetSym
  263.           END;
  264.           CheckSym(colon, 13);
  265.           IF sym = ident THEN qualident(tagfldtyp)
  266.             ELSE err(10)
  267.           END;
  268.           IF (tagfldtyp # NIL) & (tagfldtyp^.class = Typ) THEN
  269.             typ := tagfldtyp^.typ
  270.           ELSE err(52)
  271.           END;
  272.           IF fld1 # NIL THEN fld1^.typ := typ; AllocFld(fld1, adr) END;
  273.           CheckSym(of, 23); VariantPart; adr := maxadr;
  274.           CheckSym(end, 20)
  275.         END;
  276.         IF sym = semicolon THEN GetSym
  277.         ELSIF sym = ident THEN err(12)
  278.         ELSE EXIT
  279.         END
  280.       END
  281.     END;
  282.     maxadr := adr
  283.   END FieldListSequence;
  284.  
  285.   PROCEDURE FormalType(VAR typ: StrPtr);
  286.   VAR objtyp: ObjPtr;
  287.   BEGIN typ := undftyp;
  288.     IF sym = array THEN
  289.       GetSym; typ := NewStr(Array);
  290.       WITH typ^ DO
  291.         strobj := NIL; size := DynArrDesSize; dyn := TRUE
  292.       END;
  293.       CheckSym(of, 23);
  294.       IF sym = ident THEN
  295.         qualident(objtyp);
  296.         IF (objtyp # NIL) & (objtyp^.class = Typ) THEN
  297.           typ^.ElemTyp := objtyp^.typ
  298.         ELSE err(52)
  299.         END
  300.       ELSE err(10)
  301.       END
  302.     ELSIF sym = ident THEN
  303.       qualident(objtyp);
  304.       IF (objtyp # NIL) & (objtyp^.class = Typ) THEN
  305.         typ := objtyp^.typ
  306.       ELSE typ := undftyp; err(52)
  307.       END
  308.     ELSE err(10)
  309.     END
  310.   END FormalType;
  311.  
  312.   PROCEDURE FormalTypeList(proctyp: StrPtr);
  313.   VAR obj: ObjPtr; par, par0, par1: ParPtr; isvar: BOOLEAN;
  314.   BEGIN par := NIL;
  315.     IF (sym = ident) OR (sym = var) OR (sym = array) THEN
  316.       LOOP
  317.         IF sym = var THEN GetSym; isvar := TRUE ELSE isvar := FALSE END;
  318.         par := NewPar(0, isvar, par); FormalType(par^.typ);
  319.         IF sym = comma THEN GetSym
  320.         ELSIF sym = ident THEN err(11)
  321.         ELSE EXIT
  322.         END
  323.       END
  324.     END;
  325.     CheckSym(rparen, 15);
  326.     par1 := NIL; (*reverse list*)
  327.     WHILE par # NIL DO
  328.       par0 := par; par := par0^.next; par0^.next := par1; par1 := par0
  329.     END;
  330.     proctyp^.firstPar := par1;
  331.     IF sym = colon THEN
  332.       GetSym; proctyp^.resTyp := undftyp;
  333.       IF sym = ident THEN qualident(obj);
  334.         IF (obj # NIL) & (obj^.class = Typ) THEN proctyp^.resTyp := obj^.typ
  335.           ELSE err(52)
  336.         END
  337.       ELSE err(10)
  338.       END
  339.     ELSE proctyp^.resTyp := notyp
  340.     END
  341.   END FormalTypeList;
  342.  
  343.   PROCEDURE ArrayType(VAR typ: StrPtr);
  344.   VAR a,b: INTEGER;
  345.   BEGIN typ := NewStr(Array); typ^.dyn := FALSE; a := 0;
  346.     SimpleType(typ^.IndexTyp);
  347.     WITH typ^.IndexTyp^ DO
  348.       IF form # Range THEN
  349.         err(94); form := Range; RBaseTyp := inttyp; min := 0; max := 0
  350.       END;
  351.       a := min; b := max
  352.     END;
  353.     IF sym = of THEN
  354.       GetSym; Type(typ^.ElemTyp)
  355.     ELSIF sym = comma THEN
  356.       GetSym; ArrayType(typ^.ElemTyp)
  357.     ELSE err(23)
  358.     END;
  359.     IF b >= 0 THEN
  360.       IF b - MaxInt >= a THEN err(210); a := b END
  361.     ELSIF a < 0 THEN
  362.       IF b >= a + MaxInt THEN err(210); a := b END
  363.     END;
  364.     a := b-a+1; b := typ^.ElemTyp^.size;
  365.     IF (b = 0) OR (MaxInt DIV b >= a) THEN a := a*b ELSE err(210); a := 4 END;
  366.     typ^.size := ((-a) MOD 2) + a;
  367.   END ArrayType;
  368.  
  369.   PROCEDURE Type(VAR typ: StrPtr);
  370.   VAR obj: ObjPtr; btyp: StrPtr;
  371.   BEGIN
  372.     IF sym < lparen THEN err(33);
  373.       REPEAT GetSym UNTIL sym >= lparen
  374.     END;
  375.     IF sym = array THEN
  376.       GetSym; ArrayType(typ)
  377.     ELSIF sym = record THEN
  378.       GetSym; typ := NewStr(Record); NewScope(Typ);
  379.       FieldListSequence(typ^.size, 0); typ^.firstFld := topScope^.next;
  380.       typ^.size := ((-typ^.size) MOD 2) + typ^.size;
  381.       CheckSym(end, 20); CloseScope
  382.     ELSIF sym = set THEN
  383.       GetSym; CheckSym(of, 23);
  384.       typ := NewStr(Set); SimpleType(typ^.SBaseTyp);
  385.       btyp := typ^.SBaseTyp;
  386.       IF btyp^.form = Enum THEN
  387.         IF btyp^.NofConst > WordSize THEN err(209) END
  388.       ELSIF btyp^.form = Range THEN
  389.         IF (btyp^.min < 0) OR (btyp^.max >= WordSize) THEN err(209) END
  390.       ELSE err(60)
  391.       END;
  392.       typ^.size := SetTypSize
  393.     ELSIF sym = pointer THEN
  394.       GetSym; typ := NewStr(Pointer);
  395.       typ^.BaseId := 0; typ^.size := PointerTypSize; CheckSym(to, 24);
  396.       IF sym = ident THEN qualident(obj);
  397.         IF obj = NIL THEN typ^.BaseId := id; KeepId (*forward ref*)
  398.         ELSIF obj^.class = Typ THEN typ^.PBaseTyp := obj^.typ
  399.         ELSE err(52)
  400.         END
  401.       ELSE Type(typ^.PBaseTyp)
  402.       END
  403.     ELSIF sym = procedure THEN
  404.       GetSym; typ := NewStr(ProcTyp); typ^.size := ProcTypSize;
  405.       IF sym = lparen THEN
  406.         GetSym; FormalTypeList(typ)
  407.       ELSE typ^.resTyp := notyp;
  408.       END
  409.     ELSE
  410.       SimpleType(typ)
  411.     END;
  412.     IF (sym < semicolon) OR (else < sym) THEN err(34);
  413.       WHILE (sym < ident) OR (else < sym) & (sym < begin) DO
  414.         GetSym
  415.       END
  416.     END
  417.   END Type;
  418.  
  419.   PROCEDURE selector(VAR x: Item; obj: ObjPtr);
  420.   VAR y: Item;
  421.   BEGIN GenItem(x, obj, Scope);
  422.     LOOP
  423.       IF sym = lbrak THEN GetSym;
  424.         LOOP Expression(y); GenIndex(x, y);
  425.           IF sym = comma THEN GetSym ELSE EXIT END
  426.         END;
  427.         CheckSym(rbrak, 16)
  428.       ELSIF sym = period THEN
  429.         GetSym;
  430.         IF sym = ident THEN
  431.           IF (x.typ # NIL) & (x.typ^.form = Record) THEN
  432.             obj := FindInScope(id, x.typ^.firstFld); GenField(x, obj)
  433.           ELSE err(57)
  434.           END;
  435.           GetSym
  436.         ELSE err(10)
  437.         END
  438.       ELSIF sym = arrow THEN
  439.         GetSym; GenDeRef(x)
  440.       ELSE EXIT
  441.       END
  442.     END
  443.   END selector;
  444.  
  445.   PROCEDURE ActualParameters(VAR x: Item; fpar: ParPtr);
  446.   VAR apar: Item;
  447.   BEGIN
  448.     IF sym # rparen THEN
  449.       LOOP Expression(apar);
  450.         IF fpar # NIL THEN
  451.           GenParam(apar, fpar); fpar := fpar^.next
  452.         ELSE err(64)
  453.         END;
  454.         IF sym = comma THEN GetSym
  455.         ELSIF (lparen <= sym) & (sym <= ident) THEN err(11); GetSym;
  456.         ELSE EXIT
  457.         END
  458.       END
  459.     END;
  460.     IF fpar # NIL THEN err(65) END
  461.   END ActualParameters;
  462.  
  463.   PROCEDURE StandProcCall(VAR p: Item);
  464.   VAR x: Item; m: Standard; n: INTEGER;
  465.   BEGIN m := p.proc^.std; n := 0;
  466.     IF m = Halt THEN GenHalt(0) ELSE
  467.       CheckSym(lparen, 22);
  468.       LOOP Expression(x); GenVal(x);
  469.         GenStParam(p, x, m, n, sym = comma); INC(n);
  470.         IF sym = comma THEN GetSym ELSIF sym # ident THEN EXIT END
  471.       END;
  472.       CheckSym(rparen, 15); GenStFct(m, n)
  473.     END
  474.   END StandProcCall;
  475.  
  476.   PROCEDURE Element(VAR x: Item);
  477.   VAR e1, e2: Item;
  478.   BEGIN Expression(e1); GenVal(e1);
  479.     IF sym = ellipsis THEN
  480.       GetSym; Expression(e2); GenVal(e2);
  481.       GenSet(x, e1, e2)
  482.     ELSE GenSingSet(x, e1)
  483.     END;
  484.   END Element;
  485.  
  486.   PROCEDURE Sets(VAR x: Item; styp: StrPtr);
  487.   VAR y: Item;
  488.   BEGIN x.typ := styp; y.typ := styp;
  489.     IF sym # rbrace THEN
  490.       Element(x);
  491.       LOOP
  492.         IF sym = comma THEN GetSym
  493.         ELSIF (lparen <= sym) & (sym <= ident) THEN err(11)
  494.         ELSE EXIT
  495.         END;
  496.         Element(y); GenOp(plus, x, y)
  497.       END
  498.     ELSE SetconMd(x, 0D, styp);
  499.     END;
  500.     CheckSym(rbrace, 17)
  501.   END Sets;
  502.  
  503.   PROCEDURE Factor(VAR x: Item);
  504.   VAR obj: ObjPtr; xt: StrPtr; fpar: ParPtr; savedRegs: LONGINT;
  505.   BEGIN
  506.     IF sym < lparen THEN err(31);
  507.       REPEAT GetSym UNTIL sym >= lparen
  508.     END;
  509.     IF sym = ident THEN
  510.       qualident(obj);
  511.       IF sym = lbrace THEN
  512.         GetSym;
  513.         IF (obj # NIL) & (obj^.class = Typ) &
  514.            (obj^.typ^.form = Set) THEN Sets(x, obj^.typ)
  515.         ELSE err(52); Sets(x, bitstyp)
  516.         END
  517.       ELSE
  518.         selector(x, obj);
  519.         IF (x.mode = codMd) & (x.proc^.std # NonStand) THEN StandProcCall(x)
  520.         ELSIF sym = lparen THEN GetSym;
  521.           IF x.mode = typMd THEN err(260);
  522.             xt := x.typ; Expression(x);
  523.             ConvertTyp(xt, x); x.typ := xt;
  524.           ELSE PrepCall(x, fpar, savedRegs);
  525.             ActualParameters(x, fpar); GenCall(x, savedRegs);
  526.           END;
  527.           CheckSym(rparen, 15)
  528.         END
  529.       END
  530.     ELSIF sym = number THEN
  531.       GetSym;
  532.       x.mode := conMd;
  533.       CASE numtyp OF
  534.         1: x.typ := inttyp;  x.val.I  := intval
  535.       | 2: x.typ := dbltyp;  x.val.D  := dblval
  536.       | 3: x.typ := chartyp; x.val.Ch := CHR(intval MOD 256)
  537.       | 4: x.typ := realtyp; x.val.R  := realval
  538.       | 5: x.typ := lrltyp;  x.val.X  := lrlval
  539.       END
  540.     ELSIF sym = string THEN
  541.       x.typ := stringtyp; x.mode := conMd;
  542.       AllocString(id, x.val.D0, x.val.D1); x.val.D2 := 0; GetSym
  543.     ELSIF sym = lparen THEN
  544.       GetSym; Expression(x); CheckSym(rparen, 15)
  545.     ELSIF sym = lbrace THEN GetSym; Sets(x, bitstyp)
  546.     ELSIF sym = not THEN
  547.       GetSym; Factor(x); GenNot(x)
  548.     ELSE err(31); SetregMd(x, 0, undftyp);
  549.     END
  550.   END Factor;
  551.  
  552.   PROCEDURE Term(VAR x: Item);
  553.   VAR y: Item; mulop: Symbol;
  554.   BEGIN Factor(x);
  555.     WHILE (times <= sym) & (sym <= and) DO
  556.       mulop := sym; GetSym;
  557.       IF mulop = and THEN GenAnd(x) END;
  558.       Factor(y); GenOp(mulop, x, y)
  559.     END
  560.   END Term;
  561.  
  562.   PROCEDURE SimpleExpression(VAR x: Item);
  563.   VAR y: Item; addop: Symbol;
  564.   BEGIN
  565.     IF sym = minus THEN
  566.       GetSym; Term(x); GenNeg(x)
  567.     ELSE
  568.       IF sym = plus THEN GetSym END;
  569.       Term(x)
  570.     END;
  571.     WHILE (plus <= sym) & (sym <= or) DO
  572.       addop := sym; GetSym;
  573.       IF addop = or THEN GenOr(x) END;
  574.       Term(y); GenOp(addop, x, y)
  575.     END
  576.   END SimpleExpression;
  577.  
  578.   PROCEDURE Expression(VAR x: Item);
  579.   VAR y: Item; relation: Symbol;
  580.   BEGIN SimpleExpression(x);
  581.     IF (eql <= sym) & (sym <= in) THEN
  582.       relation := sym; GetSym;
  583.       GenVal(x);
  584.       SimpleExpression(y);
  585.       GenVal(y);
  586.       IF relation = in THEN GenIn(x,y)
  587.       ELSE GenOp(relation,x,y) END;
  588.     END
  589.   END Expression;
  590.  
  591.   PROCEDURE Priority;
  592.   VAR x: Item;
  593.   BEGIN
  594.     IF sym = lbrak THEN
  595.       GetSym; ConstExpression(x);
  596.       IF (x.typ = inttyp) & (x.val.I < 16) THEN curPrio := x.val.I
  597.         ELSE err(147)
  598.       END;
  599.       CheckSym(rbrak, 16)
  600.     ELSE curPrio := 0
  601.     END
  602.   END Priority;
  603.  
  604.   PROCEDURE ImportList(impmod: ObjPtr);
  605.   VAR obj: ObjPtr;
  606.   BEGIN
  607.     IF (impmod # NIL) & (impmod^.class # Module) THEN
  608.       err(55); impmod := NIL
  609.     END;
  610.     LOOP
  611.       IF sym = ident THEN
  612.         IF impmod = NIL THEN obj := FindImport(id)
  613.         ELSE obj := FindInScope(id, impmod^.root);
  614.           IF (obj # NIL) & NOT obj^.exported THEN obj := NIL END
  615.         END;
  616.         IF obj # NIL THEN NewImp(topScope, obj) ELSE err(50) END;
  617.         GetSym
  618.       ELSE err(10)
  619.       END;
  620.       IF sym = comma THEN GetSym
  621.       ELSIF sym = ident THEN err(11)
  622.       ELSE EXIT
  623.       END
  624.     END;
  625.     CheckSym(semicolon, 12)
  626.   END ImportList;
  627.  
  628.   PROCEDURE ExportList;
  629.   VAR obj: ObjPtr;
  630.   BEGIN
  631.     LOOP
  632.       IF sym = ident THEN
  633.         obj := NewObj(id, Temp); KeepId; GetSym
  634.       ELSE err(10)
  635.       END;
  636.       IF sym = comma THEN GetSym
  637.       ELSIF sym = ident THEN err(11)
  638.       ELSE EXIT
  639.       END
  640.     END;
  641.     CheckSym(semicolon, 12)
  642.   END ExportList;
  643.  
  644.   PROCEDURE Block(ancestor: ObjPtr; qual: BOOLEAN; VAR adr: INTEGER; VAR L0: INTEGER);
  645.   VAR obj, last: ObjPtr; newtypdef: BOOLEAN;
  646.       id0, s: INTEGER; x: Item; typ: StrPtr;
  647.       L1, exits, loopLev, blockEnd: INTEGER; exitTab: ExitTable;
  648.  
  649.  
  650.   PROCEDURE ChangeAllRefs(opaS, newS: StrPtr);
  651.   VAR mod: ObjPtr;
  652.  
  653.     PROCEDURE ChangeTyp(VAR t: StrPtr); FORWARD;
  654.  
  655.     PROCEDURE ChangeParams(first: ParPtr);
  656.     VAR par: ParPtr;
  657.     BEGIN par := first;
  658.       WHILE par # NIL DO
  659.         ChangeTyp(par^.typ); par := par^.next;
  660.       END;
  661.     END ChangeParams;
  662.  
  663.     PROCEDURE ChangeFields(first: ObjPtr);
  664.     VAR obj: ObjPtr;
  665.     BEGIN obj := first;
  666.       WHILE obj # NIL DO
  667.         ChangeTyp(obj^.typ); obj := obj^.next;
  668.       END;
  669.     END ChangeFields;
  670.  
  671.     PROCEDURE ChangeTyp(VAR t: StrPtr);
  672.     VAR this: StrPtr;
  673.     BEGIN this := t;
  674.       IF this # NIL THEN
  675.         WITH this^ DO
  676.           CASE form OF
  677.           | Pointer: IF PBaseTyp = opaS THEN PBaseTyp := newS END;
  678.           | ProcTyp: ChangeParams(firstPar); ChangeTyp(resTyp);
  679.           | Opaque:  IF this = opaS THEN t := newS END;
  680.           | Array:   ChangeTyp(ElemTyp);
  681.           | Record:  ChangeFields(firstFld);
  682.           ELSE (* nothing for all other variants *)
  683.           END;
  684.         END;
  685.       END;
  686.     END ChangeTyp;
  687.  
  688.     PROCEDURE ChangeObjects(root: ObjPtr);
  689.     VAR obj: ObjPtr;
  690.     BEGIN obj := root;
  691.       WHILE obj # NIL DO
  692.         WITH obj^ DO
  693.           CASE class OF
  694.           | Header, Temp:
  695.           | Const, Typ,
  696.             Var, Field: ChangeTyp(typ); (* change object's main type *)
  697.           | Proc:       ChangeParams(firstParam); ChangeTyp(typ);
  698.           | Code:       ChangeParams(firstArg); ChangeTyp(typ);
  699.           | Module:
  700.           END;
  701.         END;
  702.         obj := obj^.next;
  703.       END;
  704.     END ChangeObjects;
  705.  
  706.   BEGIN
  707.     mod := ModList^.next;
  708.     WHILE mod # NIL DO ChangeObjects(mod^.firstObj); mod := mod^.next END;
  709.     IF ancestor # mainmod THEN err(101) END;
  710.   END ChangeAllRefs;
  711.  
  712.  
  713.   PROCEDURE FormalParameters(proc: ObjPtr);
  714.   VAR isvar: BOOLEAN; size: INTEGER;
  715.       par, par0, par1: ParPtr; typ0: StrPtr;
  716.   BEGIN par := NIL; size := 0;
  717.     IF (sym = ident) OR (sym = var) THEN
  718.       LOOP par1 := par; isvar := FALSE;
  719.         IF sym = var THEN GetSym; isvar := TRUE END;
  720.         LOOP
  721.           IF sym = ident THEN
  722.             par := NewPar(id, isvar, par); KeepId; GetSym
  723.           ELSE err(10)
  724.           END;
  725.           IF sym = comma THEN GetSym
  726.           ELSIF sym = ident THEN err(11)
  727.           ELSIF sym = var THEN err(11); GetSym
  728.           ELSE EXIT
  729.           END
  730.         END;
  731.         CheckSym(colon, 13); FormalType(typ0); par0 := par;
  732.         WHILE par0 # par1 DO
  733.           par0^.typ := typ0; AllocPar(par0, size); par0 := par0^.next;
  734.         END;
  735.         IF sym = semicolon THEN GetSym
  736.         ELSIF sym = ident THEN err(12)
  737.         ELSE EXIT
  738.         END
  739.       END
  740.     END;
  741.     par1 := NIL; (*reverse list*)
  742.     WHILE par # NIL DO
  743.       par0 := par; par := par0^.next; par0^.next := par1; par1 := par0
  744.     END;
  745.     proc^.firstParam := par1; proc^.pd^.size := ABS(size); (*of param area*)
  746.     CheckSym(rparen, 15)
  747.   END FormalParameters;
  748.  
  749.   PROCEDURE CheckParameters(proc: ObjPtr);
  750.   VAR isvar: BOOLEAN;
  751.       par, par0, par1: ParPtr; typ0: StrPtr;
  752.   BEGIN par0 := proc^.firstParam;
  753.     IF (sym = ident) OR (sym = var) THEN
  754.       LOOP par1 := par0; isvar := FALSE;
  755.         IF sym = var THEN GetSym; isvar := TRUE END;
  756.         LOOP
  757.           IF sym = ident THEN
  758.             IF par0 # NIL THEN par0^.name := id; par0 := par0^.next
  759.               ELSE err(66)
  760.             END;
  761.             KeepId; GetSym
  762.           ELSE err(10)
  763.           END;
  764.           IF sym = comma THEN GetSym
  765.           ELSIF sym = ident THEN err(11)
  766.           ELSIF sym = var THEN err(11); GetSym
  767.           ELSE EXIT
  768.           END
  769.         END;
  770.         CheckSym(colon, 13); FormalType(typ0); par := par1;
  771.         WHILE par # par0 DO
  772.           IF (par^.typ # typ0) &
  773.             ((par^.typ^.form # Array) OR (typ0^.form # Array) OR
  774.              (par^.typ^.ElemTyp # typ0^.ElemTyp)) THEN err(69)
  775.           END;
  776.           IF par^.varpar # isvar THEN err(68) END;
  777.           par := par^.next
  778.         END;
  779.         IF sym = semicolon THEN GetSym
  780.         ELSIF sym = ident THEN err(12)
  781.         ELSE EXIT
  782.         END
  783.       END
  784.     END;
  785.     IF par0 # NIL THEN err(70) END;
  786.     CheckSym(rparen, 15)
  787.   END CheckParameters;
  788.  
  789.   PROCEDURE MakeParameterObjects(proc: ObjPtr);
  790.   VAR par: ParPtr; obj: ObjPtr; adr: INTEGER;
  791.   BEGIN par := proc^.firstParam;
  792.     IF curLev = 1 THEN
  793.       adr := GlbParStartAdr + proc^.pd^.size;
  794.     ELSE
  795.       adr := LocParStartAdr + proc^.pd^.size;
  796.     END;
  797.     WHILE par # NIL DO
  798.       obj := NewObj(par^.name, Var); (*name field no longer used*)
  799.       WITH obj^ DO
  800.         typ := par^.typ; vmod := 0; vlev := curLev; varpar := par^.varpar;
  801.         AllocPar(par, adr); vadr := adr;
  802.       END;
  803.       par := par^.next
  804.     END
  805.   END MakeParameterObjects;
  806.  
  807.   PROCEDURE ProcedureDeclaration(VAR proc: ObjPtr);
  808.   VAR i, L0, L1: INTEGER; adr: INTEGER; par, res: ObjPtr;
  809.   BEGIN
  810.     proc := Find(id);
  811.     IF (proc # NIL) & (proc^.class = Proc) & (proc^.pmod = 0) &
  812.        ((proc^.pd^.adr = 0) & (curLev = 0) & isimp OR (*heading in def mod*)
  813.         proc^.pd^.forward & (proc^.pd^.lev = curLev)) THEN (*forward*)
  814.       IF proc^.pd^.adr = 0 THEN proc^.pd^.exp := TRUE END;
  815.       CheckSym(ident, 10);
  816.       IF sym = lparen THEN
  817.         GetSym; CheckParameters(proc);
  818.         IF sym = colon THEN GetSym;
  819.           IF sym = ident THEN qualident(res);
  820.             IF (res = NIL) OR (res^.class # Typ) OR (res^.typ # proc^.typ) THEN
  821.               err(71)
  822.             END
  823.           ELSE err(10)
  824.           END
  825.         ELSIF proc^.typ # notyp THEN err(72)
  826.         END
  827.       ELSIF proc^.firstParam # NIL THEN err(73)
  828.       END
  829.     ELSE (*new procedure*)
  830.       proc := NewObj(id, Proc); KeepId;
  831.       WITH proc^ DO
  832.         pmod := 0; typ := notyp; firstParam := NIL;
  833.       END;
  834.       WITH proc^.pd^ DO
  835.         forward := FALSE; exp := FALSE;
  836.         lev := curLev; adr := 0; size := 0; INC(pno); num := pno;
  837.       END;
  838.       CheckSym(ident, 10);
  839.       IF sym = lparen THEN
  840.         GetSym; FormalParameters(proc);
  841.         IF sym = colon THEN
  842.           GetSym; proc^.typ := undftyp;
  843.           IF sym = ident THEN qualident(res);
  844.             IF (res # NIL) & (res^.class = Typ) THEN proc^.typ := res^.typ
  845.             ELSE err(52)
  846.             END
  847.           ELSE err(10)
  848.           END
  849.         END
  850.       END
  851.     END;
  852.     CheckSym(semicolon, 12);
  853.     IF sym = code THEN
  854.       GetSym; DEC(pno);
  855.       WITH proc^ DO
  856.         IF pd^.exp OR pd^.forward THEN err(74) END;
  857.         class := Code; std := NonStand; ConstExpression(x);
  858.         IF x.typ = inttyp THEN cnum := x.val.I
  859.         ELSE cnum := 0; err(133)
  860.         END;
  861.       END;
  862.       CheckSym(semicolon, 12);
  863.     ELSIF NOT isdef THEN
  864.       i := proc^.pd^.adr;
  865.       MarkHeap; NewScope(Proc); INC(curLev);
  866.       IF sym = forward THEN GetSym;
  867.         WITH proc^.pd^ DO
  868.           IF exp OR forward THEN err(74) END;
  869.           forward := TRUE; exp := FALSE;
  870.           lev := curLev-1; GenFJ(i); adr := i-2;
  871.         END;
  872.         (*MakeParameterObjects(proc)*)
  873.       ELSE MakeParameterObjects(proc);
  874.         IF proc^.pd^.forward THEN fixup(i+2) END;
  875.         proc^.pd^.adr := pc; proc^.pd^.forward := FALSE;
  876.         L0 := 0; GenEnter(L1, proc^.pd^.lev); GenFJ(L0);
  877.         adr := LocVarStartAdr; Block(proc, FALSE, adr, L0); FixupWith(L1, adr);
  878.       END;
  879.       DEC(curLev); CloseScope; ReleaseHeap; CheckSym(semicolon, 12);
  880.     END
  881.   END ProcedureDeclaration;
  882.  
  883.   PROCEDURE ModuleDeclaration(VAR mod: ObjPtr; VAR adr: INTEGER; VAR L0: INTEGER);
  884.   VAR prio: INTEGER; qual: BOOLEAN; impmod: ObjPtr;
  885.   BEGIN qual := FALSE; CheckSym(ident, 10);
  886.     mod := NewObj(id, Module); KeepId;
  887.     INC(mno); mod^.modno := mno; prio := curPrio; Priority;
  888.     CheckSym(semicolon, 12); NewScope(Module);
  889.     WHILE (sym = from) OR (sym = import) DO impmod := NIL;
  890.       IF sym = from THEN GetSym;
  891.         IF sym = ident THEN
  892.           impmod := FindImport(id); GetSym
  893.         ELSE err(10)
  894.         END;
  895.         CheckSym(import, 30)
  896.       ELSE GetSym
  897.       END;
  898.       ImportList(impmod)
  899.     END;
  900.     IF sym = export THEN GetSym;
  901.       IF sym = qualified THEN GetSym; qual := TRUE END;
  902.       ExportList
  903.     END;
  904.     Block(mod, qual, adr, L0);
  905.     CloseScope; curPrio := prio
  906.   END ModuleDeclaration;
  907.  
  908.  
  909.   PROCEDURE StatSeq;
  910.   VAR obj: ObjPtr; fpar: ParPtr; x, y: Item; L0, L1, s, e: INTEGER;
  911.       savedRegs: LONGINT;
  912.  
  913.     PROCEDURE CasePart;
  914.     VAR x: Item; n: INTEGER; L0, L1: INTEGER;
  915.         tab: ARRAY [0..NofCases-1] OF LabelRange;
  916.     BEGIN n := 0;
  917.       Expression(x); GenCase1(x, L0); CheckSym(of, 23);
  918.       LOOP
  919.         IF sym < bar THEN
  920.           CaseLabelList(x.typ, n, tab);
  921.           CheckSym(colon, 13); StatSeq; GenCase2
  922.         END;
  923.         IF sym = bar THEN GetSym ELSE EXIT END
  924.       END;
  925.       L1 := pc;
  926.       IF sym = else THEN
  927.         GetSym; StatSeq; GenCase2
  928.       ELSE GenHalt(1); GenCase2
  929.       END;
  930.       RefPoint; GenCase3(x, L0, L1, n, tab)
  931.     END CasePart;
  932.  
  933.     PROCEDURE ForPart;
  934.     VAR obj: ObjPtr;
  935.         v, e1, e2, e3: Item;
  936.         L0, L1: INTEGER;
  937.     BEGIN obj := NIL;
  938.       IF sym = ident THEN
  939.         obj := Find(id);
  940.         IF obj # NIL THEN
  941.           IF (obj^.class # Var) OR obj^.varpar OR (obj^.vmod > 0) THEN err(75) END
  942.         ELSE err(50)
  943.         END;
  944.         GetSym
  945.       ELSE err(10)
  946.       END;
  947.       GenItem(v, obj, Scope);
  948.       IF sym = becomes THEN GetSym ELSE err(19);
  949.         IF sym = eql THEN GetSym END
  950.       END;
  951.       Expression(e1); GenVal(e1); GenFor1(v, e1);
  952.       CheckSym(to, 24); Expression(e2); GenVal(e2); GenFor2(v, e1, e2);
  953.       IF sym = by THEN
  954.         GetSym; ConstExpression(e3)
  955.       ELSE SetconMd(e3, 1D, inttyp);
  956.       END;
  957.       GenFor3(v, e2, e3, L0, L1);
  958.       CheckSym(do, 25); StatSeq; GenFor4(v, e2, e3, L0, L1)
  959.     END ForPart;
  960.  
  961.   BEGIN
  962.     LOOP
  963.       IF sym < ident THEN err(35);
  964.         REPEAT GetSym UNTIL sym >= ident
  965.       END;
  966.       IF sym = ident THEN
  967.         RefPoint; qualident(obj); selector(x, obj);
  968.         IF sym = becomes THEN
  969.           GetSym; Expression(y); GenAssign(x, y)
  970.         ELSIF sym = eql THEN
  971.           err(19); GetSym; Expression(y); GenAssign(x, y)
  972.         ELSIF (x.mode = codMd) & (x.proc^.std # NonStand) THEN
  973.           StandProcCall(x);
  974.           IF x.typ # notyp THEN err(76) END
  975.         ELSE PrepCall(x, fpar, savedRegs);
  976.           IF sym = lparen THEN
  977.             GetSym; ActualParameters(x, fpar); CheckSym(rparen, 15)
  978.           ELSIF fpar # NIL THEN err(65)
  979.           END;
  980.           GenCall(x, savedRegs);
  981.           IF x.typ # notyp THEN err(76) END
  982.         END
  983.       ELSIF sym = if THEN
  984.         GetSym; RefPoint; Expression(x); GenCFJ(x, L0);
  985.         CheckSym(then, 27); StatSeq; L1 := 0;
  986.         WHILE (sym = elsif) DO
  987.           GetSym; GenFJ(L1); FixLink(L0); RefPoint; Expression(x);
  988.           GenCFJ(x, L0); CheckSym(then, 27); StatSeq
  989.         END;
  990.         IF sym = else THEN
  991.           GetSym; GenFJ(L1); FixLink(L0); StatSeq
  992.         ELSE FixLink(L0)
  993.         END;
  994.         FixLink(L1); CheckSym(end, 20)
  995.       ELSIF sym = case THEN
  996.         GetSym; RefPoint; CasePart; CheckSym(end, 20)
  997.       ELSIF sym = while THEN
  998.         GetSym; L1 := pc; RefPoint; Expression(x); GenCFJ(x, L0);
  999.         CheckSym(do, 25); StatSeq; GenBJ(L1); FixLink(L0);
  1000.         CheckSym(end, 20)
  1001.       ELSIF sym = repeat THEN
  1002.         GetSym; L0 := pc; StatSeq;
  1003.         IF sym = until THEN
  1004.           GetSym; RefPoint; Expression(x); GenCBJ(x, L0)
  1005.         ELSE err(26)
  1006.         END
  1007.       ELSIF sym = loop THEN
  1008.         GetSym; INC(loopLev); GenLoop1(s, e, exits);
  1009.         L0 := pc; StatSeq; GenBJ(L0); CheckSym(end, 20);
  1010.         GenLoop2(s, e, exits, exitTab); DEC(loopLev);
  1011.       ELSIF sym = for THEN
  1012.         GetSym; RefPoint; ForPart; CheckSym(end, 20)
  1013.       ELSIF sym = with THEN
  1014.         GetSym; x.typ := NIL;
  1015.         IF sym = ident THEN
  1016.           qualident(obj); selector(x, obj);
  1017.           IF x.typ^.form = Record THEN
  1018.             NewScope(Typ); GenWith(x, adr); topScope^.name := wlev;
  1019.             topScope^.right := x.typ^.firstFld;
  1020.           ELSE err(57); x.typ := NIL
  1021.           END
  1022.         ELSE err(10)
  1023.         END;
  1024.         CheckSym(do, 25); StatSeq; CheckSym(end, 20);
  1025.         IF x.typ # NIL THEN CloseScope END;
  1026.         GenWith2;
  1027.       ELSIF sym = exit THEN
  1028.         GetSym;
  1029.         IF loopLev > 0 THEN GenExit(exits, exitTab) ELSE err(39) END;
  1030.       ELSIF sym = return THEN GetSym;
  1031.         IF sym < semicolon THEN Expression(x)
  1032.         ELSE
  1033.           x.typ := notyp;
  1034.           IF ancestor^.typ # notyp THEN err(139) END;
  1035.         END;
  1036.         GenResult(x, ancestor, blockEnd)
  1037.       END;
  1038.       CheckRegs;
  1039.       IF sym = semicolon THEN GetSym
  1040.       ELSIF (sym <= ident) OR (if <= sym) & (sym <= for) THEN err(12)
  1041.       ELSE EXIT
  1042.       END
  1043.     END
  1044.   END StatSeq;
  1045.  
  1046.   PROCEDURE CheckExports(obj: ObjPtr);
  1047.   BEGIN
  1048.     IF obj # NIL THEN
  1049.       IF obj^.class = Temp THEN Mark(80)
  1050.       ELSIF ~qual & obj^.exported THEN (*import in outer scope*)
  1051.         NewImp(topScope^.left, obj)
  1052.       END;
  1053.       CheckExports(obj^.left); CheckExports(obj^.right)
  1054.     END
  1055.   END CheckExports;
  1056.  
  1057.   PROCEDURE CheckUDProc(obj: ObjPtr);
  1058.   BEGIN (*check for undefined procedure bodies*)
  1059.     WHILE obj # NIL DO
  1060.       IF (obj^.class = Proc) & (obj^.pmod = 0) &
  1061.          ((obj^.pd^.adr = 0) OR obj^.pd^.forward) THEN err(89)
  1062.       END;
  1063.       obj := obj^.next
  1064.     END
  1065.   END CheckUDProc;
  1066.  
  1067.   BEGIN (*Block*)
  1068.     LOOP
  1069.       IF sym = const THEN
  1070.         GetSym;
  1071.         WHILE sym = ident DO
  1072.           id0 := id; KeepId; GetSym;
  1073.           IF sym = eql THEN
  1074.             GetSym; ConstExpression(x)
  1075.           ELSIF sym = becomes THEN
  1076.             err(18); GetSym; ConstExpression(x)
  1077.           ELSE err(18)
  1078.           END;
  1079.           obj := NewObj(id0, Const); obj^.typ := x.typ; obj^.conval := x.val;
  1080.           IF (x.typ = stringtyp) & (obj^.conval.D2 = 0) THEN
  1081.             obj^.conval.D2 := id; KeepId
  1082.           END;
  1083.           CheckSym(semicolon, 12)
  1084.         END
  1085.       ELSIF sym = type THEN
  1086.         GetSym;
  1087.         WHILE sym = ident DO
  1088.           typ := undftyp; obj := NIL; newtypdef := TRUE;
  1089.           IF isimp & (curLev = 0) THEN
  1090.             obj := Find(id);
  1091.             IF (obj # NIL) & (obj^.class = Typ) & (obj^.typ^.form = Opaque) THEN
  1092.               newtypdef := FALSE
  1093.             END
  1094.           END;
  1095.           IF newtypdef THEN id0 := id; KeepId END;
  1096.           GetSym;
  1097.           IF sym = eql THEN
  1098.             GetSym; Type(typ)
  1099.           ELSIF (sym = becomes) OR (sym = colon) THEN
  1100.             err(18); GetSym; Type(typ)
  1101.           ELSIF NOT isdef THEN err(18)
  1102.           ELSE typ := NewStr(Opaque); typ^.size := PointerTypSize
  1103.           END;
  1104.           IF newtypdef THEN
  1105.             obj := NewObj(id0, Typ); obj^.typ := typ; obj^.mod := mainmod;
  1106.             IF typ^.strobj = NIL THEN typ^.strobj := obj END;
  1107.           ELSIF typ^.size = PointerTypSize THEN ChangeAllRefs(obj^.typ, typ)
  1108.           ELSE err(101)
  1109.           END;
  1110.           CheckUDP(obj, topScope^.right); (*check for undefined pointer types*)
  1111.           CheckSym(semicolon, 12)
  1112.         END
  1113.       ELSIF sym = var THEN
  1114.         GetSym;
  1115.         WHILE sym = ident DO last := topScope^.last; obj := last;
  1116.           LOOP
  1117.             IF sym = ident THEN
  1118.               obj := NewObj(id, Var); KeepId; GetSym
  1119.             ELSE err(10)
  1120.             END;
  1121.             IF sym = comma THEN GetSym
  1122.             ELSIF sym = ident THEN err(11)
  1123.             ELSE EXIT
  1124.             END
  1125.           END;
  1126.           CheckSym(colon, 13); Type(typ);
  1127.           WHILE (last # obj) & (last # NIL) DO
  1128.             last := last^.next;
  1129.             IF last = NIL THEN last := obj END;
  1130.             last^.typ := typ;
  1131.             WITH last^ DO
  1132.               varpar := FALSE; vmod := 0; vlev := curLev;
  1133.             END;
  1134.             AllocVar(last, adr);
  1135.           END;
  1136.           CheckSym(semicolon, 12)
  1137.         END
  1138.       ELSIF sym = procedure THEN
  1139.         GetSym; ProcedureDeclaration(obj)
  1140.       ELSIF sym = module THEN
  1141.         GetSym; ModuleDeclaration(obj, adr, L0); CheckSym(semicolon, 12);
  1142.         GenFJ(L0)
  1143.       ELSE
  1144.         IF (sym # begin) & (sym # end) THEN err(36);
  1145.           REPEAT GetSym UNTIL (sym >= begin) OR (sym = end)
  1146.         END;
  1147.         IF (sym <= begin) OR (sym = eof) THEN EXIT END
  1148.       END
  1149.     END;
  1150.  
  1151.     exits := 0; loopLev := 0; blockEnd := 0; (*label used in RETURN*)
  1152.     IF NOT isdef THEN
  1153.       IF pc - L0 = 2 THEN pc := pc - 4 ELSE fixup(L0) END;
  1154.     END;
  1155.     IF ancestor^.class = Module THEN
  1156.       CheckExports(topScope^.right);
  1157.       ancestor^.firstObj := topScope^.next; ancestor^.root := topScope^.right
  1158.     ELSE (*procedure*)
  1159.       ancestor^.firstLocal := topScope^.next;
  1160.       obj := topScope^.next;
  1161.       WHILE obj # NIL DO
  1162.         IF (obj^.typ^.form = Array) & obj^.typ^.dyn & NOT obj^.varpar THEN
  1163.           CopyDynArray(obj^.vadr, obj^.typ^.ElemTyp^.size)
  1164.         END;
  1165.         obj := obj^.next
  1166.       END;
  1167.     END;
  1168.     IF NOT isdef THEN CheckUDProc(topScope^.next) END;
  1169.     IF sym = begin THEN
  1170.       IF isdef THEN err(37) END;
  1171.       GetSym; StatSeq; RefPoint
  1172.     END;
  1173.     (*IF ancestor^.class = Proc THEN*)
  1174.       GenReturn(ancestor, blockEnd);
  1175.       IF (ancestor^.class = Proc) & NOT isdef THEN
  1176.         ancestor^.pd^.size := pc - ancestor^.pd^.adr
  1177.       END;
  1178.     (*END;*)
  1179.     CheckSym(end, 20); IF NOT scanerr THEN OutUnit(ancestor) END;
  1180.     IF sym = ident THEN
  1181.       IF Diff(id, ancestor^.name) # 0 THEN err(77) END;
  1182.       GetSym
  1183.     ELSE err(10)
  1184.     END
  1185.   END Block;
  1186.  
  1187.   PROCEDURE CompilationUnit;
  1188.   VAR id0, adr: INTEGER; L0: INTEGER;
  1189.       hdr, importMod: ObjPtr; impok, ok: BOOLEAN;
  1190.       FName, TName: ARRAY [0..NL] OF CHAR;
  1191.       p: Path; f: File; i: INTEGER; path1: Path;
  1192.  
  1193.     PROCEDURE GetFileName(j: INTEGER; VAR FName: ARRAY OF CHAR; ext: ARRAY OF CHAR);
  1194.     VAR i, L: INTEGER;
  1195.     BEGIN i := 0; L := ORD(IdBuf[j]) + j - 1;
  1196.       WHILE j < L DO
  1197.         INC(j); FName[i] := IdBuf[j]; INC(i)
  1198.       END;
  1199.       j := 0; L := HIGH(ext);
  1200.       WHILE j <= L DO
  1201.        FName[i] := ext[j]; INC(i); INC(j)
  1202.       END;
  1203.       FName[i] := 0C
  1204.     END GetFileName;
  1205.  
  1206.     PROCEDURE ImportModule;
  1207.     VAR adr, pno, i: INTEGER; f: File; p: Path; ok: BOOLEAN;
  1208.     BEGIN
  1209.       IF sym = ident THEN
  1210.         IF Diff(id, sysmod^.name) = 0 THEN importMod := sysmod
  1211.         ELSE
  1212.           GetFileName(id, FileName, ".SBM");
  1213.           InRef(FileName, hdr, adr, pno);
  1214.           WriteLn; WriteString(" - "); WriteString(FileName);
  1215.           IF hdr # NIL THEN importMod := hdr^.right
  1216.           ELSE impok := FALSE;
  1217.             importMod := NIL; WriteString(" not found (or bad)")
  1218.           END
  1219.         END;
  1220.         GetSym
  1221.       ELSE err(10)
  1222.       END;
  1223.     END ImportModule;
  1224.  
  1225.     PROCEDURE Out(n: INTEGER);
  1226.     VAR k: INTEGER;
  1227.         d: ARRAY [0..5] OF INTEGER;
  1228.     BEGIN k := 0; n := ABS(n); Write(" ");
  1229.       REPEAT d[k] := n MOD 10; n := n DIV 10; INC(k) UNTIL n = 0;
  1230.       REPEAT DEC(k); Write(CHR(d[k]+60B)) UNTIL k = 0
  1231.     END Out;
  1232.  
  1233.   BEGIN isdef := FALSE; isimp := FALSE; impok := TRUE;
  1234.     curLev := 0; curPrio := 0; mno := 0;
  1235.     GetSym;
  1236.     IF sym = definition THEN GetSym; isdef := TRUE
  1237.     ELSIF sym = implementation THEN GetSym; isimp := TRUE
  1238.     END;
  1239.     IF sym = module THEN
  1240.       GetSym;
  1241.       IF sym = ident THEN
  1242.         id0 := id; mainmod^.name := id0; KeepId; GetSym;
  1243.         IF NOT isdef THEN Priority END;
  1244.         CheckSym(semicolon, 12); MarkHeap; NewScope(Module);
  1245.         IF isimp THEN
  1246.           GetFileName(id0, FName, ".SBM");
  1247.           InRef(FName, hdr, adr, pno);
  1248.           WriteLn; WriteString(" - "); WriteString(FName);
  1249.           IF hdr # NIL THEN importMod := hdr^.right;
  1250.                topScope^.right := importMod^.root;  (*mainmod*)
  1251.                topScope^.next := hdr^.next; topScope^.last := hdr^.last
  1252.           ELSE importMod := NIL;
  1253.             WriteString(" not found (or bad)"); impok := FALSE
  1254.           END
  1255.         ELSE adr := GlbVarStartAdr; pno := 0; mainmod^.key := sysmod^.key
  1256.         END;
  1257.         WHILE (sym = from) OR (sym = import) DO
  1258.           IF sym = from THEN
  1259.             GetSym; ImportModule; CheckSym(import, 30);
  1260.             ImportList(importMod)
  1261.           ELSE (*sym = import*) GetSym;
  1262.             LOOP ImportModule;
  1263.               IF importMod # NIL THEN NewImp(topScope, importMod) END;
  1264.               IF sym = comma THEN GetSym
  1265.               ELSIF sym # ident THEN EXIT
  1266.               END
  1267.             END;
  1268.             CheckSym(semicolon, 12)
  1269.           END
  1270.         END;
  1271.         IF sym = export THEN
  1272.           GetSym; err(38);
  1273.           WHILE sym # semicolon DO GetSym END;
  1274.           GetSym
  1275.         END;
  1276.         IF impok THEN
  1277.           IF isdef THEN
  1278.             GetFileName(id0, FName, ".SBM");
  1279.           ELSE
  1280.             GetFileName(id0, FName, ".RFM");
  1281.             GenEnterMod(ModList, ModNo, pno); L0 := 0; GenFJ(L0)
  1282.           END;
  1283.           AddPath(path, FName, TName);
  1284.           WriteLn;
  1285.           ExtLookup(RefFile, TName, TRUE, ok);
  1286.           IF ok THEN
  1287.             GetCurrentPath(path1);
  1288.             WriteString(" + "); WriteString(path1); WriteString(FName);
  1289.           ELSE
  1290.             WriteString(" + "); WriteString(FName); WriteString(" not opened")
  1291.           END;
  1292.           OpenRef; Block(mainmod, TRUE, adr, L0);
  1293.           IF sym # period THEN err(14) END;
  1294.           IF NOT scanerr THEN
  1295.             IF NOT isdef THEN
  1296.               GenExitMod;
  1297.               GetFileName(id0, FName, ".OBM"); AddPath(path, FName, TName);
  1298.               WriteLn; WriteString(" + ");
  1299.               GetCurrentPath(path1);
  1300.               WriteString(path1); WriteString(FName); Out(pc);
  1301.               OutCodeFile(TName, mainmod^.key, ABS(adr), pno, id0, ModList);
  1302.             END;
  1303.             CloseRef(adr, pno); Close(RefFile);
  1304.             IF RefFile.res = notdone THEN err(223) END;
  1305.           ELSE Delete(RefFile)
  1306.           END
  1307.         END;
  1308.         CloseScope; ReleaseHeap
  1309.       ELSE err(10)
  1310.       END;
  1311.     ELSE err(28)
  1312.     END;
  1313.     IF scanerr THEN WriteString(" errors detected") END
  1314.   END CompilationUnit;
  1315.  
  1316.  
  1317. BEGIN
  1318.   ProcessorID(processor); WriteString(processor);
  1319.   WriteString(" Modula-2 Compiler V3.3.3."); WriteLn;
  1320.   WriteString("Programming in Modula-2, 4th Edition."); WriteLn;
  1321.   WriteString("ETH Zuerich, NW/HS/WH, 11-Nov-94."); WriteLn;
  1322.   Lookup(source, 'err.DAT', FALSE); FileName[0] := 0C;
  1323.   IF source.res = done THEN
  1324.     LOOP ReadChar(source, ch);
  1325.       IF ch = 300C THEN i := 0;
  1326.         REPEAT ReadChar(source, ch); FileName[i] := ch; INC(i) UNTIL ch = 0C
  1327.       ELSE EXIT
  1328.       END
  1329.     END;
  1330.     Close(source);
  1331.   END;
  1332.   LOOP rngchk := TRUE; ovflchk := FALSE;
  1333.     WriteString("in> ");
  1334.     ReadFileName(FileName, "MOD", "TEXT", BusyRead, Write, ok);
  1335.     IF NOT ok THEN EXIT END;
  1336.     IF termCh = "/" THEN Write("/");
  1337.       LOOP Read(ch); ch := CAP(ch);
  1338.         IF ch = "R" THEN Write(ch); rngchk := FALSE
  1339.         ELSIF ch = "V" THEN Write(ch); ovflchk := TRUE
  1340.         ELSIF ch <= " " THEN EXIT
  1341.         ELSE Write("?")
  1342.         END
  1343.       END
  1344.     END;
  1345.     ExtLookup(source, FileName, FALSE, ok);
  1346.     IF ok THEN
  1347.       GetCurrentPath(path);
  1348.       AddPath(path, FileName, FileName);
  1349.       GetTime(TM);
  1350.       WITH sysmod^.key^ DO
  1351.         k0 := TM.day; k1 := TM.minute; k2 := TM.millisecond
  1352.       END;
  1353.       InitScanner(FileName); InitTableHandler; InitRef;
  1354.       InitM2LM; InitM2HM; InitM2EM;
  1355.       CompilationUnit; Close(source);
  1356.     ELSE WriteString(" -- not found");
  1357.     END;
  1358.     WriteLn; FileName[0] := 0C;
  1359.   END;
  1360.   CloseScanner; WriteLn;
  1361.  
  1362.  
  1363. END CompileN. (* Copyright Departement Informatik, ETH Zuerich, Switzerland, 1992 *)
  1364.